home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / vb_g_prt / gprinter.bas < prev    next >
Encoding:
BASIC Source File  |  1995-09-06  |  44.5 KB  |  1,319 lines
  1. '----------------------------------------------------------------
  2. 'Copyright 1994   Unger Business Systems  All Rights Reserved
  3. 'This code is distributed as shareware.  If you use it, you
  4. 'are required by law to register it.  Please contact Unger
  5. 'Business Systems at 11926 Barrett Brae, Houston, TX 77072-4004
  6. 'or call (713) 498-8517.  Registration fee is $20.00 US
  7. 'See the README.TXT file for more information
  8. '
  9. 'All code, forms, modules, controls, etc. are provided without
  10. 'warranty or liability
  11. '----------------------------------------------------------------
  12.  
  13. Option Explicit
  14.    
  15. Global CRLF$
  16.  
  17. Dim di%, lf As LOGFONT, lp As LOGPEN
  18. Dim dev$, DevName$, DevOutput$, DeviceDriver$
  19. Dim dm As DEVMODE, dmout As DEVMODE
  20. Dim libhnd%
  21. Dim bufsize%
  22. Dim dminstring$, dmoutstring$
  23. Dim dminaddr&, dmoutaddr&
  24. Dim dinfo As DOCINFO
  25. Dim docname$, CurrX%, CurrY%
  26. Dim oldcursor%, CurrentFont%, oldfont%, Oldpen%
  27. Dim lpRect As RECT
  28. Global GenPaperWidth#, GenPaperLength#, GenPaperSize%
  29. Global AbortPrinting%
  30. Global DoShowDevMode%, DoShowDevCaps%
  31. Global DoShowPaperSize%
  32.  
  33. Global Const MaxLinesArray = 30
  34. Global LinesArray(MaxLinesArray)  As String
  35. Global RemainStr$
  36.  
  37. Global NumberOfLines%
  38.  
  39. Const DefPtSize = 10
  40.  
  41. Global CurrentPen%
  42.  
  43. Global PrtXRes%, PrtYRes%, FontIsBold%, OriginalFontWeight%
  44.  
  45. Global Const DT_TOP = &H0
  46. Global Const DT_LEFT = &H0
  47. Global Const DT_CENTER = &H1
  48. Global Const DT_RIGHT = &H2
  49. Global Const DT_VCENTER = &H4
  50. Global Const DT_BOTTOM = &H8
  51. Global Const DT_WORDBREAK = &H10
  52. Global Const DT_SINGLELINE = &H20
  53. Global Const DT_EXPANDTABS = &H40
  54. Global Const DT_TABSTOP = &H80
  55. Global Const DT_NOCLIP = &H100
  56. Global Const DT_EXTERNALLEADING = &H200
  57. Global Const DT_CALCRECT = &H400
  58. Global Const DT_NOPREFIX = &H800
  59. Global Const DT_INTERNAL = &H1000
  60. Global Const SYSTEM_FONT = 13
  61.  
  62. ' color enable/disable for color printers
  63. Global Const DMCOLOR_MONOCHROME = 1
  64. Global Const DMCOLOR_COLOR = 2
  65.  
  66. ' paper selections
  67. ' Warning: The PostScript driver mistakingly uses DMPAPER_ values between
  68. ' 50 and 56.  Don't use this range when defining new paper sizes.
  69.  
  70. Global Const DMPAPER_LETTER = 1         'Letter 8 1/2 x 11 in
  71. Global Const DMPAPER_LETTERSMALL = 2    'Letter Small 8 1/2 x 11 in
  72. Global Const DMPAPER_TABLOID = 3        'Tabloid 11 x 17 in
  73. Global Const DMPAPER_LEDGER = 4         'Ledger 17 x 11 in
  74. Global Const DMPAPER_LEGAL = 5          'Legal 8 1/2 x 14 in
  75. Global Const DMPAPER_STATEMENT = 6      'Statement 5 1/2 x 8 1/2 in
  76. Global Const DMPAPER_EXECUTIVE = 7     'Executive 7 1/4 x 10 1/2 in
  77. Global Const DMPAPER_A3 = 8             'A3 297 x 420 mm
  78. Global Const DMPAPER_A4 = 9             'A4 210 x 297 mm
  79. Global Const DMPAPER_A4SMALL = 10       'A4 Small 210 x 297 mm
  80. Global Const DMPAPER_A5 = 11            'A5 148 x 210 mm
  81. Global Const DMPAPER_B4 = 12            'B4 250 x 354
  82. Global Const DMPAPER_B5 = 13            'B5 182 x 257 mm
  83. Global Const DMPAPER_FOLIO = 14         'Folio 8 1/2 x 13 in
  84. Global Const DMPAPER_QUARTO = 15        'Quarto 215 x 275 mm
  85. Global Const DMPAPER_10X14 = 16         '10x14 in
  86. Global Const DMPAPER_11X17 = 17         '11x17 in
  87. Global Const DMPAPER_NOTE = 18          'Note 8 1/2 x 11 in
  88. Global Const DMPAPER_ENV_9 = 19         'Envelope #9 3 7/8 x 8 7/8
  89. Global Const DMPAPER_ENV_10 = 20        'Envelope #10 4 1/8 x 9 1/2
  90. Global Const DMPAPER_ENV_11 = 21        'Envelope #11 4 1/2 x 10 3/8
  91. Global Const DMPAPER_ENV_12 = 22        'Envelope #12 4 \276 x 11
  92. Global Const DMPAPER_ENV_14 = 23        'Envelope #14 5 x 11 1/2
  93. Global Const DMPAPER_CSHEET = 24        'C size sheet
  94. Global Const DMPAPER_DSHEET = 25        'D size sheet
  95. Global Const DMPAPER_ESHEET = 26        'E size sheet
  96. Global Const DMPAPER_ENV_DL = 27        'Envelope DL 110 x 220mm
  97. Global Const DMPAPER_ENV_C5 = 28        'Envelope C5 162 x 229 mm
  98. Global Const DMPAPER_ENV_C3 = 29        'Envelope C3  324 x 458 mm
  99. Global Const DMPAPER_ENV_C4 = 30        'Envelope C4  229 x 324 mm
  100. Global Const DMPAPER_ENV_C6 = 31        'Envelope C6  114 x 162 mm
  101. Global Const DMPAPER_ENV_C65 = 32       'Envelope C65 114 x 229 mm
  102. Global Const DMPAPER_ENV_B4 = 33        'Envelope B4  250 x 353 mm
  103. Global Const DMPAPER_ENV_B5 = 34        'Envelope B5  176 x 250 mm
  104. Global Const DMPAPER_ENV_B6 = 35        'Envelope B6  176 x 125 mm
  105. Global Const DMPAPER_ENV_ITALY = 36     'Envelope 110 x 230 mm
  106. Global Const DMPAPER_ENV_MONARCH = 37   'Envelope Monarch 3.875 x 7.5 in
  107. Global Const DMPAPER_ENV_PERSONAL = 38  '6 3/4 Envelope 3 5/8 x 6 1/2 in
  108. Global Const DMPAPER_FANFOLD_US = 39    'US Std Fanfold 14 7/8 x 11 in
  109. Global Const DMPAPER_FANFOLD_STD_GERMAN = 40  'German Std Fanfold 8 1/2 x 12 in
  110. Global Const DMPAPER_FANFOLD_LGL_GERMAN = 41  'German Legal Fanfold 8 1/2 x 13 in
  111.  
  112. Global Const DMPAPER_USER = 256
  113.  
  114. ' printer bin selections
  115. Global Const DMBIN_UPPER = 1
  116. Global Const DMBIN_ONLYONE = 1
  117. Global Const DMBIN_LOWER = 2
  118. Global Const DMBIN_MIDDLE = 3
  119. Global Const DMBIN_MANUAL = 4
  120. Global Const DMBIN_ENVELOPE = 5
  121. Global Const DMBIN_ENVMANUAL = 6
  122. Global Const DMBIN_AUTO = 7
  123. Global Const DMBIN_TRACTOR = 8
  124. Global Const DMBIN_SMALLFMT = 9
  125. Global Const DMBIN_LARGEFMT = 10
  126. Global Const DMBIN_LARGECAPACITY = 11
  127. Global Const DMBIN_CASSETTE = 14
  128.  
  129. Global Const DMBIN_USER = 256  'device specific bins start here
  130.  
  131. ' print qualities
  132. Global Const DMRES_DRAFT = -1
  133. Global Const DMRES_LOW = -2
  134. Global Const DMRES_MEDIUM = -3
  135. Global Const DMRES_HIGH = -4
  136.  
  137. ' Printer duplex enable
  138. Global Const DMDUP_SIMPLEX = 1
  139. Global Const DMDUP_VERTICAL = 2
  140. Global Const DMDUP_HORIZONTAL = 3
  141.  
  142. ' TrueType options
  143. Global Const DMTT_BITMAP = 1    'print TT fonts as graphics
  144. Global Const DMTT_DOWNLOAD = 2  'download TT fonts as soft fonts
  145. Global Const DMTT_SUBDEV = 3    'substitute device fonts for TT fonts
  146.  
  147. '  Pen Styles
  148. Global Const PS_SOLID = 0
  149. Global Const PS_DASH = 1        '  -------
  150. Global Const PS_DOT = 2 '  .......
  151. Global Const PS_DASHDOT = 3     '  _._._._
  152. Global Const PS_DASHDOTDOT = 4  '  _.._.._
  153. Global Const PS_NULL = 5
  154. Global Const PS_INSIDEFRAME = 6
  155.  
  156. Global Const TMPF_FIXED_PITCH = 1
  157. Global Const TMPF_VECTOR = 2
  158. Global Const TMPF_DEVICE = 8
  159. Global Const TMPF_TRUETYPE = 4
  160.  
  161. Global Const DM_IN_BUFFER = 8
  162. Global Const DM_IN_PROMPT = 4
  163. Global Const DM_OUT_BUFFER = 2
  164. Global Const DMORIENT_PORTRAIT = 1
  165. Global Const DMORIENT_LANDSCAPE = 2
  166. Global Const SP_OUTOFDISK = (-4)
  167.  
  168. ' field selection bits
  169. Global Const DM_ORIENTATION = &H1&
  170. Global Const DM_PAPERSIZE = &H2&
  171. Global Const DM_PAPERLENGTH = &H4&
  172. Global Const DM_PAPERWIDTH = &H8&
  173. Global Const DM_SCALE = &H10&
  174. Global Const DM_COPIES = &H100&
  175. Global Const DM_DEFAULTSOURCE = &H200&
  176. Global Const DM_PRINTQUALITY = &H400&
  177. Global Const DM_COLOR = &H800&
  178. Global Const DM_DUPLEX = &H1000&
  179. Global Const DM_YRESOLUTION = &H2000&
  180. Global Const DM_TTOPTION = &H4000&
  181.  
  182. ' device capabilities indices
  183. Global Const DC_FIELDS = 1
  184. Global Const DC_PAPERS = 2
  185. Global Const DC_PAPERSIZE = 3
  186. Global Const DC_MINEXTENT = 4
  187. Global Const DC_MAXEXTENT = 5
  188. Global Const DC_BINS = 6
  189. Global Const DC_DUPLEX = 7
  190. Global Const DC_SIZE = 8
  191. Global Const DC_EXTRA = 9
  192. Global Const DC_VERSION = 10
  193. Global Const DC_DRIVER = 11
  194. Global Const DC_BINNAMES = 12
  195. Global Const DC_ENUMRESOLUTIONS = 13
  196. Global Const DC_FILEDEPENDENCIES = 14
  197. Global Const DC_TRUETYPE = 15
  198. Global Const DC_PAPERNAMES = 16
  199. Global Const DC_ORIENTATION = 17
  200. Global Const DC_COPIES = 18
  201.  
  202. ' DC_TRUETYPE bit fields
  203. Global Const DCTT_BITMAP = &H1&
  204. Global Const DCTT_DOWNLOAD = &H2&
  205. Global Const DCTT_SUBDEV = &H4&
  206.  
  207. Global Const PD_RETURNDC = &H100&
  208.  
  209. Declare Function GetTextExtentPoint% Lib "GDI" (ByVal hDC%, ByVal lpszString$, ByVal cbString%, lpSize As SIZEAPI)
  210. Declare Function GetStockObject% Lib "GDI" (ByVal nIndex%)
  211. Declare Function SelectObject% Lib "GDI" (ByVal hDC%, ByVal hObject%)
  212. Declare Function GetObject2% Lib "GDI" Alias "GetObject" (ByVal hObject%, ByVal nCount%, ByVal lpObject&)
  213. Declare Function CreateFontIndirect% Lib "GDI" (lpLogFont As LOGFONT)
  214. Declare Function DeleteObject% Lib "GDI" (ByVal hObject%)
  215. Declare Function MoveTo& Lib "GDI" (ByVal hDC%, ByVal x%, ByVal y%)
  216. Declare Function LineTo% Lib "GDI" (ByVal hDC%, ByVal x%, ByVal y%)
  217. Declare Function Rectangle% Lib "GDI" (ByVal hDC%, ByVal X1%, ByVal Y1%, ByVal X2%, ByVal Y2%)
  218. Declare Function EndPage% Lib "GDI" (ByVal hDC%)
  219. Declare Function EndDocAPI% Lib "GDI" Alias "EndDoc" (ByVal hDC%)
  220. Declare Function DeleteDC% Lib "GDI" (ByVal hDC%)
  221. Declare Function DrawText% Lib "User" (ByVal hDC%, ByVal lpStr$, ByVal nCount%, lpRect As RECT, ByVal wFormat%)
  222. Declare Function SetAbortProc% Lib "GDI" (ByVal hDC%, ByVal abrtprc&)
  223. Declare Function CreatePen% Lib "GDI" (ByVal nPenStyle%, ByVal nWidth%, ByVal crColor&)
  224. Declare Function GetTextMetrics% Lib "GDI" (ByVal hDC%, lpMetrics As TEXTMETRIC)
  225. Declare Function GetTextFace% Lib "GDI" (ByVal hDC%, ByVal nCount%, ByVal lpFacename$)
  226. Declare Function StartPage% Lib "GDI" (ByVal hDC%)
  227. Declare Function StartDoc% Lib "GDI" (ByVal hDC%, lpdi As DOCINFO)
  228. Declare Function LoadLibrary% Lib "Kernel" (ByVal lpLibFileName$)
  229. Declare Function CreateDC% Lib "GDI" (ByVal lpDriverName$, ByVal lpDeviceName$, ByVal lpOutput$, ByVal lpInitData&)
  230. Declare Function SetSysModalWindow% Lib "User" (ByVal hWnd%)
  231.  
  232. Function ClipString$ (ByVal prhdc%, ByVal TString$, ByVal MaxLength#)
  233.    'returns maximum number of characters from TString which will
  234.    'fit in a space which is MaxLength inches wide
  235.    'uses current font to determine text size
  236.  
  237.    Dim TLen#, I%, TStr$
  238.         
  239.    I = 0
  240.    Do While 1
  241.       I = I + 1
  242.       If I > Len(TString) Then
  243.      ClipString = TString
  244.      Exit Do
  245.       End If
  246.       TStr = Left$(TString, I)
  247.       TLen = GetTextWidth(prhdc, TStr) / PrtYRes
  248.       If TLen > MaxLength Then
  249.      ClipString = Left$(TString, I - 1)
  250.      Exit Do
  251.       End If
  252.    Loop
  253. End Function
  254.  
  255. Sub DefaultFontSetup (ByVal prhdc%)
  256.    'called by GenPrinterSetup
  257.  
  258.    Dim di%, CurrLogFont%, Result%
  259.  
  260.    'temporarily select in a stock font to return current logical font
  261.    CurrLogFont = SelectObject%(GeneralPrinter.hDC, GetStockObject(SYSTEM_FONT))
  262.    DoEvents
  263.  
  264.    'stuff info on current logical font into lf (LOGFONT structure)
  265.    di% = GetObject2%(CurrLogFont%, 50, agGetAddressForObject&(lf))
  266.    DoEvents
  267.    
  268.    'restore the current logical font
  269.    di% = SelectObject%(GeneralPrinter.hDC, CurrLogFont)
  270.    DoEvents
  271.  
  272.    'set font to Arial with default pt size and weight
  273.    lf.lfFaceName = "Arial"
  274.    lf.lfHeight = -(DefPtSize / 72) * PrtYRes
  275.    lf.lfWidth = .45 * lf.lfHeight
  276.    lf.lfWeight = 400
  277.  
  278.    'create "OldFont" from current lf
  279.    oldfont = CreateFontIndirect(lf)
  280.    DoEvents
  281.    
  282.    'select "OldFont" into printer
  283.    di = SelectObject(prhdc, oldfont)
  284.    DoEvents
  285.    'delete previously existing font
  286.    If di <> 0 Then Result = DeleteObject(di)
  287.    DoEvents
  288. End Sub
  289.  
  290. Sub DrawLine (ByVal prhdc%, ByVal X1!, ByVal Y1!, ByVal X2!, ByVal Y2!)
  291.    'draws a line from X1,Y1 to X2,Y2  (in inches)
  292.    Dim di%, dl&
  293.  
  294.    dl = MoveTo(prhdc, X1 * PrtXRes, Y1 * PrtYRes)
  295.  
  296.    di = LineTo(prhdc, X2 * PrtXRes, Y2 * PrtYRes)
  297.    If di = 0 Then
  298.       MsgBox "Error occurred in LineTo call in DrawLine." & CRLF & "This should not happen."
  299.    End If
  300. End Sub
  301.  
  302. Sub DrawRectangle (ByVal prhdc%, ByVal X1!, ByVal Y1!, ByVal X2!, ByVal Y2!)
  303.    'draws a rectangle with corners at X1,Y1 and X2,Y2 (in inches)
  304.    
  305.    Dim di%
  306.  
  307.    di = Rectangle(prhdc, X1 * PrtXRes, Y1 * PrtYRes, X2 * PrtXRes, Y2 * PrtYRes)
  308. End Sub
  309.  
  310. Function EndAPage% (ByVal prhdc%)
  311.     ' The system will spend a long time in the EndPage
  312.     ' function, but it will periodically call the Abort
  313.     ' procedure which in turn triggers the Callback1
  314.     ' AbortProc event.
  315.     EndAPage = EndPage(prhdc%)
  316. End Function
  317.  
  318. Function EndDocument% (ByVal prhdc%)
  319.    'called at the end of the print job
  320.  
  321.     EndDocument = EndDocAPI(prhdc%)
  322. End Function
  323.  
  324. Sub GenPrinterClose (ByVal prhdc%)
  325.    'cleans up printer
  326.  
  327.     If prhdc% <> 0 Then di% = DeleteDC%(prhdc%)
  328.     If libhnd% <> 0 Then FreeLibrary libhnd%
  329. End Sub
  330.  
  331. Function GenPrinterSetup% (ByVal TPrinterStr$, ByVal TOrientationStr$)
  332.    'This routine accepts a printer string and returns a device context
  333.  
  334.    Dim TStr$, CleanupStr$
  335.    Dim prhdc%  ' handle to printer device context
  336.  
  337.    GenPrinterSetup = 0   'if fails
  338.    dev$ = TPrinterStr
  339.    If dev$ = "" Then Exit Function
  340.    'strip out name, output, and driver
  341.    DevName$ = GetDeviceName$(dev$)
  342.    DevOutput$ = GetDeviceOutput$(dev$)
  343.    DeviceDriver$ = GetDeviceDriver$(dev$)
  344.    DoEvents
  345.  
  346.    ' Load the device driver library - exit if unavailable
  347.    libhnd% = LoadLibrary(DeviceDriver & ".drv")
  348.    DoEvents
  349.    CleanupStr = "Unable to load library: " & DeviceDriver & ".drv"
  350.    If libhnd% = 0 Then GoTo SetupCleanup
  351.  
  352.    'Find out how big the DEVMODE structure is for this printer
  353.    bufsize% = agExtDeviceMode%(GeneralPrinter.hWnd, libhnd%, 0, DevName$, DevOutput$, agGetAddressForObject(dm), 0, 0)
  354.    DoEvents
  355.    'Allocate two buffers of that size and get pointers to them
  356.    dminstring$ = String$(bufsize%, 0)
  357.    dmoutstring$ = String$(bufsize%, 0)
  358.    dminaddr& = agGetAddressForVBString&(dminstring$)
  359.    dmoutaddr& = agGetAddressForVBString&(dmoutstring$)
  360.    
  361.    'Copy DEVMODE info into dmoutstring
  362.    di% = agExtDeviceMode(GeneralPrinter.hWnd, libhnd%, dmoutaddr&, DevName$, DevOutput$, dminaddr&, 0, DM_OUT_BUFFER)
  363.    If di <> IDOK Then
  364.       Beep
  365.       MsgBox "Error returned by agExtDeviceMode: " & Str(di) & CRLF & "Printer not initialized.", MB_ICONSTOP
  366.       GoTo SetupCleanup
  367.    End If
  368.    DoEvents
  369.  
  370.    'Copy the data buffer (dmoutstring) into the DEVMODE structure
  371.    dmoutaddr& = agGetAddressForVBString&(dmoutstring$)
  372.    agCopyDataBynum dmoutaddr&, agGetAddressForObject&(dm), 68
  373.    DoEvents
  374.  
  375.    If DoShowDevMode Then ShowDevMode "Direct From Driver", dm
  376.    If DoShowDevCaps Then ShowDeviceCapabilities libhnd, DevName, DevOutput
  377.    ' Set the orientation, and set the dmField flag so that
  378.    ' the function will know that it is valid.
  379.    If TOrientationStr = "LANDSCAPE" Then
  380.       dm.dmOrientation = DMORIENT_LANDSCAPE
  381.    Else
  382.       dm.dmOrientation = DMORIENT_PORTRAIT
  383.    End If
  384.    dm.dmFields = dm.dmFields Or DM_ORIENTATION
  385.    dm.dmDriverExtra = 0   'required for PostScript printers
  386.    If DoShowDevMode Then ShowDevMode "After Changes", dm
  387.  
  388.    'create new DevMode with any changes we made
  389.    agCopyDataBynum agGetAddressForObject&(dm), agGetAddressForVBString&(dminstring$), 68
  390.    dminaddr& = agGetAddressForVBString&(dminstring$)
  391.    dmoutaddr& = agGetAddressForVBString&(dmoutstring$)
  392.    di% = agExtDeviceMode(GeneralPrinter.hWnd, libhnd%, dmoutaddr&, DevName$, DevOutput$, dminaddr&, 0, DM_IN_BUFFER Or DM_OUT_BUFFER)
  393.    If di <> IDOK Then
  394.       Beep
  395.       MsgBox "Error returned by agExtDeviceMode: " & Str(di) & CRLF & "Printer not initialized.", MB_ICONSTOP
  396.       GoTo SetupCleanup
  397.    End If
  398.    DoEvents
  399.    agCopyDataBynum agGetAddressForVBString&(dmoutstring$), agGetAddressForObject&(dmout), 68
  400.    If DoShowDevMode Then ShowDevMode "From Driver After Changes", dmout
  401.  
  402.    'Now create a DC (device context) to the  printer
  403.    prhdc = CreateDC%(DeviceDriver, DevName$, DevOutput$, agGetAddressForObject&(dmout))
  404.    DoEvents
  405.    CleanupStr = "Unable to create device context: " & CRLF & DeviceDriver & ".drv" & CRLF & DevName & CRLF & DevOutput
  406.    If prhdc% = 0 Then GoTo SetupCleanup
  407.    'ShowPrinterMetrics dmout
  408.    If dmout.dmPrintQuality > 0 Then
  409.       PrtXRes = dmout.dmPrintQuality
  410.       If dmout.dmYResolution > 0 Then
  411.      PrtYRes = dmout.dmYResolution
  412.       Else
  413.      PrtYRes = PrtXRes
  414.       End If
  415.    Else
  416.       PrtXRes = 300 'assume laser
  417.       PrtYRes = 300
  418.    End If
  419.    If PrtXRes <> 300 Then
  420.       TStr = "Printer X Resolution = " & Format(PrtXRes, "###0") & ", not 300!"
  421.       MsgBox TStr
  422.    End If
  423.    GenPaperSize = dmout.dmPaperSize
  424.    If GenPaperSize = 0 Then
  425.       GenPaperWidth = (dmout.dmPaperWidth / 100) / 2.54     'inches
  426.       GenPaperLength = (dmout.dmPaperLength / 100) / 2.54   'inches
  427.    Else
  428.       Select Case GenPaperSize
  429.      Case DMPAPER_LETTER: GenPaperWidth = 8.5
  430.      Case DMPAPER_LEGAL: GenPaperWidth = 8.5
  431.      Case DMPAPER_TABLOID: GenPaperWidth = 11#
  432.      Case DMPAPER_LEDGER: GenPaperWidth = 17#
  433.      Case Else: GenPaperWidth = 8.5   'default
  434.       End Select
  435.       Select Case GenPaperSize
  436.      Case DMPAPER_LETTER: GenPaperLength = 11#
  437.      Case DMPAPER_LEGAL: GenPaperLength = 14#
  438.      Case DMPAPER_TABLOID: GenPaperLength = 17#
  439.      Case DMPAPER_LEDGER: GenPaperLength = 11#
  440.      Case Else: GenPaperLength = 11#    'default
  441.       End Select
  442.    End If
  443.    If DoShowPaperSize Then MsgBox "Paper size is " & Str(GenPaperWidth) & " by " & Str(GenPaperLength) & CRLF & "dmout.dmPaperSize = " & Str$(dmout.dmPaperSize) & CRLF & "dmout.dmPaperWidth = " & Str$(dmout.dmPaperWidth) & CRLF & "dmout.dmPaperLength = " & Str(dmout.dmPaperLength)
  444.    
  445.    DefaultFontSetup prhdc
  446.    GenPrinterSetup = prhdc
  447.    DoEvents
  448.    SetTextX 0
  449.    SetTextY 0
  450.    Exit Function
  451.  
  452. SetupCleanup:
  453.    DoEvents
  454.    Beep
  455.    MsgBox CleanupStr, MB_ICONSTOP
  456.    If prhdc% <> 0 Then di% = DeleteDC%(prhdc%)
  457.    If libhnd% <> 0 Then FreeLibrary libhnd%
  458.    Exit Function
  459.  
  460. End Function
  461.  
  462. Function GetDeviceDriver$ (ByVal dev$)
  463. '
  464. '   This function returns the driver module name
  465. '   D. Appleman
  466. '
  467.    Dim FirstPos%, NextPos%
  468.    FirstPos% = InStr(dev$, ",")
  469.    NextPos% = InStr(FirstPos% + 1, dev$, ",")
  470.    If NextPos > 0 Then
  471.       GetDeviceDriver$ = Mid$(dev$, FirstPos% + 1, NextPos% - FirstPos% - 1)
  472.    Else
  473.       GetDeviceDriver = ""
  474.    End If
  475. End Function
  476.  
  477. Function GetDeviceName$ (ByVal dev$)
  478. '
  479. '   Retrieves the name portion of a device string
  480. '   D. Appleman
  481. '
  482.     Dim npos%
  483.     npos% = InStr(dev$, ",")
  484.     If npos > 0 Then
  485.        GetDeviceName$ = Left$(dev$, npos% - 1)
  486.     Else
  487.        GetDeviceName = ""
  488.     End If
  489. End Function
  490.  
  491. Function GetDeviceOutput$ (ByVal dev$)
  492. '
  493. '   Returns the output destination for the specified device
  494. '   D. Appleman
  495. '
  496.     Dim FirstPos%, NextPos%
  497.     FirstPos% = InStr(dev$, ",")
  498.     NextPos% = InStr(FirstPos% + 1, dev$, ",")
  499.     If NextPos > 0 Then
  500.        GetDeviceOutput = Mid$(dev$, NextPos% + 1)
  501.     Else
  502.        GetDeviceOutput = ""
  503.     End If
  504. End Function
  505.  
  506. Function GetNumberedDeviceOutput (ByVal TDevOutput$, ByVal Num%)
  507. 'returns Numth output destination from string returned by
  508. 'GetDeviceOutput
  509.    Dim FirstPos%, NextPos%, Count%, TStr$
  510.  
  511.    FirstPos = InStr(1, TDevOutput, ",")
  512.    If FirstPos = 0 Then
  513.       GetNumberedDeviceOutput = TDevOutput
  514.       Exit Function
  515.    End If
  516.    Count = 1
  517.    FirstPos = 0
  518.    Do While 1
  519.       NextPos = InStr(FirstPos + 1, TDevOutput, ",")
  520.       If Count = Num Then
  521.      If NextPos = 0 Then
  522.         TStr = Right$(TDevOutput, Len(TDevOutput) - FirstPos)
  523.      Else
  524.         TStr = Mid$(TDevOutput, FirstPos + 1, NextPos - FirstPos - 1)
  525.      End If
  526.      GetNumberedDeviceOutput = TStr
  527.      Exit Function
  528.       ElseIf NextPos = 0 Then
  529.      GetNumberedDeviceOutput = ""
  530.      'this should not occur
  531.      Exit Function
  532.       Else
  533.      Count = Count + 1
  534.      FirstPos = NextPos
  535.       End If
  536.    Loop
  537. End Function
  538.  
  539. Function GetNumDeviceOutputs% (ByVal TDevOutput)
  540. 'Takes output from GetDeviceOutput and returns number of
  541. 'output devices
  542. '(GetDeviceOutput returns output destinations separated by
  543. 'commas if more than one)
  544.  
  545.    Dim FirstPos%, NextPos%, Count%
  546.  
  547.    FirstPos = InStr(1, TDevOutput, ",")
  548.    If FirstPos = 0 Then
  549.       GetNumDeviceOutputs = 1
  550.       Exit Function
  551.    End If
  552.    Count = 2
  553.    Do While 1
  554.       NextPos = InStr(FirstPos + 1, TDevOutput, ",")
  555.       If NextPos = 0 Then Exit Do
  556.       Count = Count + 1
  557.       FirstPos = NextPos
  558.    Loop
  559.    GetNumDeviceOutputs = Count
  560. End Function
  561.  
  562. Function GetOnlyFontName$ (ByVal LongFontName$)
  563.     'returns only part of font name before first BOLD,
  564.     'ITALIC, or (
  565.  
  566.     Dim TStr$, Pos%, UTStr$
  567.  
  568.     TStr = LongFontName
  569.     UTStr = UCase$(LongFontName)
  570.     
  571.     Pos = InStr(1, UTStr, "BOLD")
  572.     If Pos > 0 Then
  573.        TStr = Trim$(Left$(LongFontName, Pos - 1))
  574.        GetOnlyFontName = TStr
  575.        Exit Function
  576.     End If
  577.  
  578.     Pos = InStr(1, UTStr, "ITALIC")
  579.     If Pos > 0 Then
  580.        TStr = Trim$(Left$(LongFontName, Pos - 1))
  581.        GetOnlyFontName = TStr
  582.        Exit Function
  583.     End If
  584.  
  585.     Pos = InStr(1, LongFontName, "(")
  586.     If Pos > 0 Then TStr = Trim$(Left$(LongFontName, Pos - 1))
  587.     GetOnlyFontName = TStr
  588. End Function
  589.  
  590. Function GetTextHeight (ByVal prhdc%, ByVal TString$)
  591.    'returns text height in logical units of device context prhdc
  592.  
  593.    Dim Result%, TPoint As SIZEAPI
  594.  
  595.    Result = GetTextExtentPoint(prhdc, TString, Len(TString), TPoint)
  596.    If Result = False Then
  597.       GetTextHeight = -1
  598.       Exit Function
  599.    End If
  600.    GetTextHeight = TPoint.y
  601. End Function
  602.  
  603. Function GetTextWidth (ByVal prhdc%, ByVal TString$)
  604.    'returns text width in logical units of device context prhdc
  605.  
  606.    Dim Result%, TPoint As SIZEAPI
  607.  
  608.    Result = GetTextExtentPoint(prhdc, TString, Len(TString), TPoint)
  609.    If Result = False Then
  610.       GetTextWidth = -1
  611.       Exit Function
  612.    End If
  613.    GetTextWidth = TPoint.x
  614. End Function
  615.  
  616. Function GetWindowsDefaultPrinter ()
  617.    Dim I%, DefPrinter$
  618.  
  619.    DefPrinter = Space$(255)
  620.    I% = GetProfileString("WINDOWS", "device", "", DefPrinter, Len(DefPrinter))
  621.    GetWindowsDefaultPrinter = Left$(DefPrinter, I)
  622. End Function
  623.  
  624. Function GetWindowsPrinterOrientation$ (TPrinterStr$)
  625.     'NOTE:  This routine may not work for every printer driver.
  626.     'It depends on whether it follows the standard convention in
  627.     'storing its state in WIN.INI
  628.  
  629.     'returns "PORTRAIT" or "LANDSCAPE"
  630.     Dim I%, PrtOrient$, TStr$, OrntStr$
  631.  
  632.     PrtOrient = Space$(255)
  633.     TStr = GetDeviceName(TPrinterStr) & "," & GetDeviceOutput(TPrinterStr)
  634.     If Mid$(TStr, Len(TStr)) = ":" Then TStr = Left$(TStr, Len(TStr) - 1)  'strip :
  635.     I% = GetProfileString(TStr, "Orientation", "1", PrtOrient, Len(PrtOrient))
  636.     OrntStr = Left$(PrtOrient, I)
  637.     If OrntStr = "1" Then
  638.     GetWindowsPrinterOrientation = "PORTRAIT"
  639.     Else
  640.     GetWindowsPrinterOrientation = "LANDSCAPE"
  641.     End If
  642. End Function
  643.  
  644. Function HiWord% (ByVal TVal&)
  645.    'used in ShowDeviceCapabilities
  646.    Const SignBit = &H80000000
  647.    
  648.    Dim SignWasSet As Integer
  649.    Dim TLong&
  650.  
  651.    SignWasSet = ((TVal And SignBit) <> 0&)
  652.    TLong = TVal And (Not SignBit)                  ' chop off sign so we can shift by dividing
  653.    TLong = (TLong \ &H10000) And &HFFFF&           ' Make sure this says (TVal \ &H10000) And &HFFFF& (needs to be long)
  654.    If SignWasSet Then TLong = TLong Or &H8000&
  655.    If TLong >= &H8000& Then TLong = TLong - &H10000' make sure it's in range acceptable to signed integer
  656.    HiWord = TLong
  657. End Function
  658.  
  659. Sub LineFeed (ByVal prhdc%)
  660.    'moves print point down by height of current font and
  661.    'to left margin
  662.  
  663.    lpRect.top = lpRect.top + GetTextHeight(prhdc, "S")   'any letter
  664.    lpRect.bottom = lpRect.top + 11 * PrtYRes
  665.    lpRect.left = 0
  666. End Sub
  667.  
  668. Function LoWord% (ByVal TVal&)
  669.    'used in ShowDeviceCapabilties
  670.    Dim TLong&
  671.  
  672.    TLong = (TVal And &HFFFF&)  'Make sure this says TVal And &HFFFF& (needs to be long)
  673.    If TLong > &H3FFF& Then TLong = TLong - &H10000
  674.    LoWord = TLong
  675. End Function
  676.  
  677. Sub PrintText (ByVal prhdc%, ByVal TString$)
  678.    'prints TString at current print point in current font
  679.  
  680.    di = DrawText(prhdc, TString, Len(TString), lpRect, DT_LEFT)
  681. End Sub
  682.  
  683. Sub PrintTextCenter (ByVal prhdc%, ByVal TString$, ByVal LeftMargin!, ByVal RightMargin!)
  684.    'centers text on page
  685.  
  686.    Dim TWidth!, TPos!
  687.  
  688.    TWidth = GetTextWidth(prhdc, TString) / PrtYRes
  689.    TPos = ((GenPaperWidth - .3 - LeftMargin - RightMargin) - TWidth) / 2
  690.    SetTextX TPos
  691.    di = DrawText(prhdc, TString, Len(TString), lpRect, DT_LEFT)
  692. End Sub
  693.  
  694. Sub SelectPrinter (ThisPrinter$, ThisOrientation$, TCaption$)
  695.    'this is a routine which encapsulates the functions of
  696.    'the PrtSetupForm
  697.    Dim OldPrinter$, OldOrientation$
  698.  
  699.    OldPrinter = ThisPrinter
  700.    OldOrientation = ThisOrientation
  701.    Load PrtSetupForm
  702.    PrtSetupForm.Caption = TCaption
  703.    PrtSetupForm!Frame1.Visible = True
  704.    PrtSetupForm!cmdSetup.Visible = False
  705.    PrtSetupForm!txtTempPrinter = GetDeviceName(ThisPrinter) & " on " & GetDeviceOutput(ThisPrinter)
  706.    PrtSetupForm!txtTempOrientation = ThisOrientation
  707.    PrtSetupForm.Show 1 'modal
  708.    If PrtSetupForm!txtTempPrinter = "" Then
  709.       ThisPrinter = OldPrinter
  710.       ThisOrientation = OldOrientation
  711.    Else
  712.       ThisPrinter = PrtSetupForm!txtTempPrinter
  713.       ThisOrientation = PrtSetupForm!txtTempOrientation
  714.    End If
  715.    Unload PrtSetupForm
  716. End Sub
  717.  
  718. Sub SetAbortCallback (ByVal prhdc%)
  719.    Dim di%
  720.     AbortPrinting% = False
  721.     di% = SetAbortProc(prhdc%, GeneralPrinter!Callback1.ProcAddress)
  722. End Sub
  723.  
  724. Sub SetPrtFontBold (ByVal prhdc%, ByVal TBold%)
  725.    'sets weight to bold if TBold is true, otherwise not bold;
  726.    'weights determined by constants below
  727.  
  728.    Const BoldWeight = 700
  729.    Const NormalWeight = 0
  730.  
  731.    Dim Result%
  732.  
  733.    If CurrentFont <> 0 Then
  734.       Result = SelectObject(prhdc, oldfont)
  735.       Result = DeleteObject(CurrentFont)
  736.       CurrentFont = 0
  737.    End If
  738.    If (TBold = True) Then
  739.       lf.lfWeight = BoldWeight
  740.    Else
  741.       lf.lfWeight = NormalWeight
  742.    End If
  743.    CurrentFont = CreateFontIndirect(lf)
  744.    oldfont = SelectObject(prhdc, CurrentFont)
  745.    'ShowFontMetrics prhdc, CurrentFont
  746. End Sub
  747.  
  748. Sub SetPrtFontItalic (ByVal prhdc%, ByVal TItalic%)
  749.    'sets font to italic if TItalic is true, otherwise not italic;
  750.  
  751.    Dim Result%
  752.  
  753.    If CurrentFont <> 0 Then
  754.       Result = SelectObject(prhdc, oldfont)
  755.       Result = DeleteObject(CurrentFont)
  756.       CurrentFont = 0
  757.    End If
  758.    If (TItalic = True) Then
  759.       lf.lfItalic = "1"
  760.    Else
  761.       lf.lfItalic = "0"
  762.    End If
  763.    CurrentFont = CreateFontIndirect(lf)
  764.    oldfont = SelectObject(prhdc, CurrentFont)
  765.    'ShowFontMetrics prhdc, CurrentFont
  766. End Sub
  767.  
  768. Sub SetPrtFontName (ByVal prhdc%, ByVal TFontName$)
  769.    'Must pass installed font name to this routine
  770.  
  771.    Dim Result%, OldHeight%
  772.  
  773.    If CurrentFont <> 0 Then
  774.       Result = SelectObject(prhdc, oldfont)
  775.       Result = DeleteObject(CurrentFont)
  776.       CurrentFont = 0
  777.    End If
  778.    lf.lfFaceName = TFontName & Chr$(0)
  779.    OldHeight = lf.lfHeight
  780.    lf.lfHeight = -(DefPtSize / 72) * PrtYRes
  781.    lf.lfWeight = 400
  782.    FontIsBold = False
  783.    CurrentFont = CreateFontIndirect(lf)
  784.    If CurrentFont = 0 Then
  785.       MsgBox "Unable to set printer font to " & TFontName
  786.       Exit Sub
  787.    End If
  788.    oldfont = SelectObject(prhdc, CurrentFont)
  789.    'ShowFontMetrics prhdc, CurrentFont
  790. End Sub
  791.  
  792. Sub SetPrtFontSize (ByVal prhdc%, ByVal TFontSize!)
  793.    'sets font size in points
  794.    'note that width is set to 0 which chooses default width
  795.    'this could be changed if desired
  796.  
  797.    Dim Result%, OldHeight%, TName$
  798.  
  799.    If CurrentFont <> 0 Then
  800.       Result = SelectObject(prhdc, oldfont)
  801.       Result = DeleteObject(CurrentFont)
  802.       CurrentFont = 0
  803.    End If
  804.    OldHeight = lf.lfHeight
  805.    lf.lfHeight = -(TFontSize / 72) * PrtYRes
  806.    TName = agGetSTringFromLPSTR$(lf.lfFaceName)
  807.    lf.lfWidth = 0
  808.    CurrentFont = CreateFontIndirect(lf)
  809.    oldfont = SelectObject(prhdc, CurrentFont)
  810.    'ShowFontMetrics prhdc, CurrentFont
  811. End Sub
  812.  
  813. Sub SetPrtFontUnderline (ByVal prhdc%, ByVal Underline%)
  814.    'underline font
  815.  
  816.    Dim Result%
  817.  
  818.    If CurrentFont <> 0 Then
  819.       Result = SelectObject(prhdc, oldfont)
  820.       Result = DeleteObject(CurrentFont)
  821.       CurrentFont = 0
  822.    End If
  823.    If (Underline = True) Then
  824.       lf.lfUnderline = "1"    'any non-blank value
  825.    Else
  826.       lf.lfUnderline = Chr(0)
  827.    End If
  828.    CurrentFont = CreateFontIndirect(lf)
  829.    oldfont = SelectObject(prhdc, CurrentFont)
  830.    'ShowFontMetrics prhdc, CurrentFont
  831. End Sub
  832.  
  833. Sub SetPrtPenWidth (ByVal prhdc%, ByVal PWidth%)
  834.    'sets printer pen in logical units
  835.  
  836.    Const Black = 0
  837.    Dim Result%
  838.  
  839.    If CurrentPen <> 0 Then
  840.       Result = SelectObject(prhdc, Oldpen)
  841.       Result = DeleteObject(CurrentPen)
  842.       CurrentPen = 0
  843.    End If
  844.    CurrentPen = CreatePen%(PS_SOLID, PWidth, Black)
  845.    Oldpen = SelectObject(prhdc, CurrentPen)
  846. End Sub
  847.  
  848. Sub SetTextPos (ByVal dx As Single, ByVal dy As Single)
  849.    'set print position in inches
  850.  
  851.    lpRect.left = dx * PrtXRes
  852.    lpRect.top = dy * PrtYRes
  853.    lpRect.right = lpRect.left + 11 * PrtXRes
  854.    lpRect.bottom = lpRect.top + 11 * PrtYRes
  855. End Sub
  856.  
  857. Sub SetTextX (ByVal dx As Single)
  858.    'set X print position while leaving Y position alone
  859.  
  860.    lpRect.left = dx * PrtXRes
  861.    lpRect.right = lpRect.left + 11 * PrtXRes
  862. End Sub
  863.  
  864. Sub SetTextY (ByVal dy As Single)
  865.    'set Y print position while leaving X alone
  866.  
  867.    lpRect.top = dy * PrtYRes
  868.    lpRect.bottom = lpRect.top + 11 * PrtYRes
  869. End Sub
  870.  
  871. Sub SetupDocInfo (ByVal AppName$)
  872.     ' The DOCINFO structure is the information that the
  873.     ' print manager will show.
  874.     docname$ = AppName
  875.     dinfo.cbSize = 10
  876.     dinfo.lpszDocName = agGetAddressForLPSTR&(docname$)
  877.     dinfo.lpszOutput = 0
  878. End Sub
  879.  
  880. Sub ShowAbortForm (ByVal ShowSystemModal%)
  881.     AbortForm.Label1 = "Press button to abort..."
  882.     AbortForm.Show
  883.     AbortForm.Refresh
  884.     If ShowSystemModal Then
  885.        di% = SetSysModalWindow(AbortForm.hWnd)
  886.     End If
  887. End Sub
  888.  
  889. Sub ShowDeviceCapabilities (ByVal hlib%, ByVal DevName$, ByVal DevPort$)
  890.    'for information purposes
  891.    Dim Result%, TBuf$, TStr$, BufLen&, TName$, TCnt&, I%
  892.    Dim LongArray&(), TabChar$
  893.  
  894.    TabChar = Chr(9)
  895.  
  896.    TBuf$ = Space(255)
  897.    TCnt = agDeviceCapabilities(hlib, DevName, DevPort, DC_BINS, agGetAddressForVBString&(TBuf), 0&)
  898.    TStr = "Bins = " & Str(TCnt) & CRLF
  899.    If TCnt > 0 Then
  900.       BufLen = 24 * TCnt
  901.       TBuf = Space(BufLen)
  902.       Result = agDeviceCapabilities(hlib, DevName, DevPort, DC_BINNAMES, agGetAddressForVBString&(TBuf), 0&)
  903.       For I = 1 To TCnt
  904.      TName = Mid$(TBuf, (I - 1) * 24 + 1, 24)
  905.      TStr = TStr & TabChar & agGetSTringFromLPSTR(TName) & CRLF
  906.       Next I
  907.    End If
  908.    Result = agDeviceCapabilities(hlib, DevName, DevPort, DC_COPIES, agGetAddressForVBString&(TBuf), 0&)
  909.    TStr = TStr & "Max copies = " & Str(Result) & CRLF
  910.    Result = agDeviceCapabilities(hlib, DevName, DevPort, DC_DRIVER, agGetAddressForVBString&(TBuf), 0&)
  911.    TStr = TStr & "Driver Version = " & Str(Result) & CRLF
  912.    Result = agDeviceCapabilities(hlib, DevName, DevPort, DC_DUPLEX, agGetAddressForVBString&(TBuf), 0&)
  913.    If Result = 1 Then
  914.       TStr = TStr & "Duplex = NO" & CRLF
  915.    Else
  916.       TStr = TStr & "Duplex = YES" & CRLF
  917.    End If
  918.    TCnt = agDeviceCapabilities(hlib, DevName, DevPort, DC_ENUMRESOLUTIONS, 0&, 0&)
  919.    If TCnt = -1 Then
  920.       TStr = TStr & "Resolutions = CAPABILITY NOT SUPPORTED" & CRLF
  921.    Else
  922.       TStr = TStr & "Resolutions = " & Str(TCnt) & CRLF
  923.       If TCnt > 0 Then
  924.      ReDim LongArray(1 To 2 * TCnt)
  925.      Result = agDeviceCapabilities(hlib, DevName, DevPort, DC_ENUMRESOLUTIONS, agGetAddressForObject(LongArray(1)), 0&)
  926.      For I = 1 To TCnt
  927.         TStr = TStr & TabChar & Str(LongArray(2 * I - 1)) & " x " & Str(LongArray(2 * I)) & CRLF
  928.      Next I
  929.       End If
  930.    End If
  931.    TCnt = agDeviceCapabilities(hlib, DevName, DevPort, DC_MAXEXTENT, 0&, 0&)
  932.    If TCnt = -1 Then
  933.       TStr = TStr & "Max Extent: CAPABILITY NOT SUPPORTED" & CRLF
  934.    Else
  935.       TStr = TStr & "Max Extent: " & Hex(HiWord(TCnt)) & "  " & Hex(LoWord(TCnt)) & CRLF
  936.    End If
  937.    TCnt = agDeviceCapabilities(hlib, DevName, DevPort, DC_MINEXTENT, 0&, 0&)
  938.    If TCnt = -1 Then
  939.       TStr = TStr & "Min Extent: CAPABILITY NOT SUPPORTED" & CRLF
  940.    Else
  941.       TStr = TStr & "Min Extent: " & Hex(HiWord(TCnt)) & "  " & Hex(LoWord(TCnt)) & CRLF
  942.    End If
  943.    TCnt = agDeviceCapabilities(hlib, DevName, DevPort, DC_PAPERNAMES, 0&, 0&)
  944.    TStr = TStr & "Paper Sizes: " & Str(TCnt) & CRLF
  945.    If TCnt > 0 Then
  946.       BufLen = 64 * TCnt
  947.       TBuf = Space(BufLen)
  948.       Result = agDeviceCapabilities(hlib, DevName, DevPort, DC_PAPERNAMES, agGetAddressForVBString&(TBuf), 0&)
  949.       For I = 1 To TCnt
  950.      TName = Mid$(TBuf, (I - 1) * 64 + 1, 64)
  951.      TStr = TStr & TabChar & agGetSTringFromLPSTR(TName) & CRLF
  952.       Next I
  953.    End If
  954.    TCnt = agDeviceCapabilities(hlib, DevName, DevPort, DC_TRUETYPE, 0&, 0&)
  955.    Select Case TCnt
  956.       Case DCTT_BITMAP: TStr = TStr & "TRUETYPE: Can print TrueType as graphics." & CRLF
  957.       Case DCTT_DOWNLOAD: TStr = TStr & "TRUETYPE: Can download TrueType fonts." & CRLF
  958.       Case DCTT_SUBDEV: TStr = TStr & "TRUETYPE: Can substitute built-in fonts." & CRLF
  959.       Case Else: TStr = TStr & "TRUETYPE: INVALID VALUE." & CRLF
  960.    End Select
  961.    MsgBox TStr
  962. End Sub
  963.  
  964. Sub ShowDevMode (ByVal HeaderStr$, dm As DEVMODE)
  965.    'for information purposes
  966.    Dim TStr$, TStr2$
  967.  
  968.    TStr = HeaderStr & CRLF & CRLF
  969.    TStr = TStr & "dmDeviceName:  " & agGetSTringFromLPSTR(dm.dmDeviceName) & CRLF
  970.    TStr = TStr & "dmSpecVersion:  "
  971.    If dm.dmSpecVersion = &H30A Then
  972.       TStr = TStr & "Windows 3.1" & CRLF
  973.    Else
  974.       TStr = TStr & Hex$(dm.dmSpecVersion) & " (Hex)" & CRLF
  975.    End If
  976.    TStr = TStr & "dmDriverVersion:  " & Hex$(dm.dmDriverVersion) & " (Hex) " & CRLF
  977.    TStr = TStr & "dmSize:  " & dm.dmSize & CRLF
  978.    TStr = TStr & "dmDriverExtra:  " & dm.dmDriverExtra & CRLF
  979.    TStr = TStr & "dmFields:  " & Hex$(dm.dmFields) & " (Hex)" & CRLF
  980.  
  981.    TStr = TStr & "dmOrientation:  "
  982.    If dm.dmFields And DM_ORIENTATION Then
  983.       Select Case dm.dmOrientation
  984.      Case DMORIENT_PORTRAIT: TStr2 = "Portrait Mode"
  985.      Case DMORIENT_LANDSCAPE: TStr2 = "Landscape Mode"
  986.      Case Else: TStr2 = Str(dm.dmOrientation)
  987.       End Select
  988.       TStr = TStr & TStr2 & CRLF
  989.    Else
  990.       TStr = TStr & "INVALID" & CRLF
  991.    End If
  992.  
  993.    TStr = TStr & "dmPaperSize:  "
  994.    If dm.dmFields And DM_PAPERSIZE Then
  995.       Select Case dm.dmPaperSize
  996.      Case DMPAPER_LETTER: TStr2 = "Letter 8 1/2 x 11 in"
  997.      Case DMPAPER_LETTERSMALL: TStr2 = "Letter Small 8 1/2 x 11 in"
  998.      Case DMPAPER_TABLOID: TStr2 = "Tabloid 11 x 17 in"
  999.      Case DMPAPER_LEDGER: TStr2 = "Ledger 17 x 11 in"
  1000.      Case DMPAPER_LEGAL: TStr2 = "Legal 8 1/2 x 14 in"
  1001.      Case DMPAPER_STATEMENT: TStr2 = "Statement 5 1/2 x 8 1/2 in"
  1002.      Case DMPAPER_EXECUTIVE: TStr2 = "Executive 7 1/4 x 10 1/2 in"
  1003.      Case DMPAPER_A3: TStr2 = "A3 297 x 420 mm"
  1004.      Case DMPAPER_A4: TStr2 = "A4 210 x 297 mm"
  1005.      Case DMPAPER_A4SMALL: TStr2 = "A4 Small 210 x 297 mm"
  1006.      Case DMPAPER_A5: TStr2 = "A5 148 x 210 mm"
  1007.      Case DMPAPER_B4: TStr2 = "B4 250 x 354"
  1008.      Case DMPAPER_B5: TStr2 = "B5 182 x 257 mm"
  1009.      Case DMPAPER_FOLIO: TStr2 = "Folio 8 1/2 x 13 in"
  1010.      Case DMPAPER_QUARTO: TStr2 = "Quarto 215 x 275 mm"
  1011.      Case DMPAPER_10X14: TStr2 = "10x14 in"
  1012.      Case DMPAPER_11X17: TStr2 = "11x17 in"
  1013.      Case DMPAPER_NOTE: TStr2 = "Note 8 1/2 x 11 in"
  1014.      Case DMPAPER_ENV_9: TStr2 = "Envelope #9 3 7/8 x 8 7/8"
  1015.      Case DMPAPER_ENV_10: TStr2 = "Envelope #10 4 1/8 x 9 1/2"
  1016.      Case DMPAPER_ENV_11: TStr2 = "Envelope #11 4 1/2 x 10 3/8"
  1017.      Case DMPAPER_ENV_12: TStr2 = "Envelope #12 4 \276 x 11"
  1018.      Case DMPAPER_ENV_14: TStr2 = "Envelope #14 5 x 11 1/2"
  1019.      Case DMPAPER_CSHEET: TStr2 = "C size sheet"
  1020.      Case DMPAPER_DSHEET: TStr2 = "D size sheet"
  1021.      Case DMPAPER_ESHEET: TStr2 = "E size sheet"
  1022.      Case DMPAPER_ENV_DL: TStr2 = "Envelope DL 110 x 220mm"
  1023.      Case DMPAPER_ENV_C5: TStr2 = "Envelope C5 162 x 229 mm"
  1024.      Case DMPAPER_ENV_C3: TStr2 = "Envelope C3  324 x 458 mm"
  1025.      Case DMPAPER_ENV_C4: TStr2 = "Envelope C4  229 x 324 mm"
  1026.      Case DMPAPER_ENV_C6: TStr2 = "Envelope C6  114 x 162 mm"
  1027.      Case DMPAPER_ENV_C65: TStr2 = "Envelope C65 114 x 229 mm"
  1028.      Case DMPAPER_ENV_B4: TStr2 = "Envelope B4  250 x 353 mm"
  1029.      Case DMPAPER_ENV_B5: TStr2 = "Envelope B5  176 x 250 mm"
  1030.      Case DMPAPER_ENV_B6: TStr2 = "Envelope B6  176 x 125 mm"
  1031.      Case DMPAPER_ENV_ITALY: TStr2 = "Envelope 110 x 230 mm"
  1032.      Case DMPAPER_ENV_MONARCH: TStr2 = "Envelope Monarch 3.875 x 7.5 in"
  1033.      Case DMPAPER_ENV_PERSONAL: TStr2 = "6 3/4 Envelope 3 5/8 x 6 1/2 in"
  1034.      Case DMPAPER_FANFOLD_US: TStr2 = "US Std Fanfold 14 7/8 x 11 in"
  1035.      Case DMPAPER_FANFOLD_STD_GERMAN: TStr2 = "German Std Fanfold 8 1/2 x 12 in"
  1036.      Case DMPAPER_FANFOLD_LGL_GERMAN: TStr2 = "German Legal Fanfold 8 1/2 x 13 in"
  1037.      Case Else: TStr2 = Str(dm.dmPaperSize)
  1038.       End Select
  1039.       TStr = TStr & TStr2 & CRLF
  1040.    Else
  1041.       TStr = TStr & "INVALID" & CRLF
  1042.    End If
  1043.  
  1044.    TStr = TStr & "dmPaperLength:  "
  1045.    If dm.dmFields And DM_PAPERLENGTH Then
  1046.       TStr = TStr & dm.dmPaperLength / 254 & " in" & CRLF
  1047.    Else
  1048.       TStr = TStr & "INVALID" & CRLF
  1049.    End If
  1050.  
  1051.    TStr = TStr & "dmPaperWidth:  "
  1052.    If dm.dmFields And DM_PAPERWIDTH Then
  1053.       TStr = TStr & dm.dmPaperWidth / 254 & " in " & CRLF
  1054.    Else
  1055.       TStr = TStr & "INVALID" & CRLF
  1056.    End If
  1057.  
  1058.    TStr = TStr & "dmScale:  "
  1059.    If dm.dmFields And DM_SCALE Then
  1060.       TStr = TStr & dm.dmScale & CRLF
  1061.    Else
  1062.       TStr = TStr & "INVALID" & CRLF
  1063.    End If
  1064.  
  1065.    TStr = TStr & "dmCopies:  "
  1066.    If dm.dmFields And DM_COPIES Then
  1067.       TStr = TStr & dm.dmCopies & CRLF
  1068.    Else
  1069.       TStr = TStr & "INVALID" & CRLF
  1070.    End If
  1071.  
  1072.    TStr = TStr & "dmDefaultSource:  "
  1073.    If dm.dmFields And DM_DEFAULTSOURCE Then
  1074.       Select Case dm.dmDefaultSource
  1075.      Case DMBIN_ONLYONE: TStr2 = "UPPER"
  1076.      Case DMBIN_LOWER: TStr2 = "LOWER"
  1077.      Case DMBIN_MIDDLE: TStr2 = "MIDDLE"
  1078.      Case DMBIN_MANUAL: TStr2 = "MANUAL"
  1079.      Case DMBIN_ENVELOPE: TStr2 = "ENVELOPE"
  1080.      Case DMBIN_ENVMANUAL: TStr2 = "ENVMANUAL"
  1081.      Case DMBIN_AUTO: TStr2 = "AUTO"
  1082.      Case DMBIN_TRACTOR: TStr2 = "TRACTOR"
  1083.      Case DMBIN_SMALLFMT: TStr2 = "SMALLFMT"
  1084.      Case DMBIN_LARGEFMT: TStr2 = "LARGEFMT"
  1085.      Case DMBIN_LARGECAPACITY: TStr2 = "LARGECAPACITY"
  1086.      Case DMBIN_CASSETTE: TStr2 = "CASSETTE"
  1087.      Case Else: TStr2 = Str(dm.dmDefaultSource)
  1088.       End Select
  1089.       TStr = TStr & TStr2 & CRLF
  1090.    Else
  1091.       TStr = TStr & "INVALID" & CRLF
  1092.    End If
  1093.  
  1094.    TStr = TStr & "dmPrintQuality:  "
  1095.    If dm.dmFields And DM_PRINTQUALITY Then
  1096.       Select Case dm.dmPrintQuality
  1097.      Case DMRES_DRAFT: TStr2 = "DRAFT"
  1098.      Case DMRES_LOW: TStr2 = "LOW"
  1099.      Case DMRES_MEDIUM: TStr2 = "MEDIUM"
  1100.      Case DMRES_HIGH: TStr2 = "HIGH"
  1101.      Case Else: TStr2 = Str(dm.dmPrintQuality)
  1102.       End Select
  1103.       TStr = TStr & TStr2 & CRLF
  1104.    Else
  1105.       TStr = TStr & "INVALID" & CRLF
  1106.    End If
  1107.  
  1108.    TStr = TStr & "dmColor:  "
  1109.    If dm.dmFields And DM_COLOR Then
  1110.       Select Case dm.dmColor
  1111.      Case DMCOLOR_MONOCHROME: TStr2 = "MONOCHROME"
  1112.      Case DMCOLOR_COLOR: TStr2 = "COLOR"
  1113.      Case Else: TStr2 = Str(dm.dmColor)
  1114.       End Select
  1115.       TStr = TStr & TStr2 & CRLF
  1116.    Else
  1117.       TStr = TStr & "INVALID" & CRLF
  1118.    End If
  1119.  
  1120.    TStr = TStr & "dmDuplex:  "
  1121.    If dm.dmFields And DM_DUPLEX Then
  1122.       Select Case dm.dmDuplex
  1123.      Case DMDUP_SIMPLEX: TStr2 = "SIMPLEX"
  1124.      Case DMDUP_VERTICAL: TStr2 = "VERTICAL"
  1125.      Case DMDUP_HORIZONTAL: TStr2 = "HORIZONTAL"
  1126.      Case Else: TStr2 = Str(dm.dmDuplex)
  1127.       End Select
  1128.       TStr = TStr & dm.dmDuplex & CRLF
  1129.    Else
  1130.       TStr = TStr & "INVALID" & CRLF
  1131.    End If
  1132.  
  1133.    TStr = TStr & "dmYResolution:  "
  1134.    If dm.dmFields And DM_YRESOLUTION Then
  1135.       Select Case dm.dmYResolution
  1136.      Case DMRES_DRAFT: TStr2 = "DRAFT"
  1137.      Case DMRES_LOW: TStr2 = "LOW"
  1138.      Case DMRES_MEDIUM: TStr2 = "MEDIUM"
  1139.      Case DMRES_HIGH: TStr2 = "HIGH"
  1140.      Case Else: TStr2 = Str(dm.dmYResolution)
  1141.       End Select
  1142.       TStr = TStr & TStr2 & CRLF
  1143.    Else
  1144.       TStr = TStr & "INVALID" & CRLF
  1145.    End If
  1146.  
  1147.    TStr = TStr & "dmTTOption:  "
  1148.    If dm.dmFields And DM_TTOPTION Then
  1149.       Select Case dm.dmTTOption
  1150.      Case DMTT_BITMAP: TStr2 = "print TT fonts as graphics"
  1151.      Case DMTT_DOWNLOAD: TStr2 = "download TT fonts as soft fonts"
  1152.      Case DMTT_SUBDEV: TStr2 = "substitute device fonts for TT fonts"
  1153.      Case Else: TStr2 = Str(dm.dmTTOption)
  1154.       End Select
  1155.       TStr = TStr & TStr2 & CRLF
  1156.    Else
  1157.       TStr = TStr & "INVALID" & CRLF
  1158.    End If
  1159.  
  1160.    MsgBox TStr, 0, "DEVMODE STRUCTURE"
  1161. End Sub
  1162.  
  1163. Sub ShowFontMetrics (ByVal prhdc%, ByVal FontToUse%)
  1164.    'useful for seeing what font characteristics are in use
  1165.  
  1166.     Dim tm As TEXTMETRIC
  1167.     Dim r$
  1168.     Dim CRLF$
  1169.     Dim oldfont%
  1170.     Dim TBuf As String * 80
  1171.  
  1172.     CRLF$ = Chr$(13) & Chr$(10)
  1173.     If FontToUse% = 0 Then
  1174.     MsgBox "Font not yet selected"
  1175.     Exit Sub
  1176.     End If
  1177.     'oldfont% = SelectObject(prhdc, FontToUse%)
  1178.     di% = GetTextMetrics(prhdc, tm)
  1179.     di% = GetTextFace(prhdc, 79, TBuf)
  1180.     ' Add to r$ only the part up to the null terminator
  1181.     r$ = "Facename = " & agGetSTringFromLPSTR$(TBuf) & CRLF$
  1182.     If (Asc(tm.tmPitchAndFamily) And TMPF_TRUETYPE) <> 0 Then r$ = r$ & "... is a TrueType font" & CRLF$
  1183.     If (Asc(tm.tmPitchAndFamily) And TMPF_DEVICE) <> 0 Then r$ = r$ & "... is a Device font" & CRLF$
  1184.     ' Curiously enough, this bit is set for variable width fonts.
  1185.     If (Asc(tm.tmPitchAndFamily) And TMPF_FIXED_PITCH) = 0 Then r$ = r$ & "... is a fixed pitch font" & CRLF$
  1186.     r$ = r$ & "Height=" & Str$(tm.tmHeight) & ", Ascent=" & Str$(tm.tmAscent) & ", Descent=" & Str$(tm.tmDescent) & CRLF$
  1187.     r$ = r$ & "Internal Leading=" & Str$(tm.tmInternalLeading) & ", External Leading=" & Str$(tm.tmExternalLeading) & CRLF$
  1188.     r$ = r$ & "Average char width=" & Str$(tm.tmAveCharWidth) & ", Max char width=" & Str$(tm.tmMaxCharWidth) & CRLF$
  1189.     r$ = r$ & "Weight=" & Str$(tm.tmWeight) & ", First char=" & Str$(Asc(tm.tmFirstChar)) & ", Last char=" & Str$(Asc(tm.tmLastChar)) & CRLF$
  1190.     r$ = r$ & "AspectX=" & Str$(tm.tmDigitizedAspectX) & ", AspectY=" & Str$(tm.tmDigitizedAspectY) & CRLF$
  1191.     
  1192.     MsgBox r$, 0, "Physical Font Metrics"
  1193.     'di% = SelectObject(prhdc, oldfont%)
  1194. End Sub
  1195.  
  1196. Sub ShowPrinterMetrics (dm As DEVMODE)
  1197.    'useful for displaying printer metrics
  1198.  
  1199.    Dim a$, CRLF$
  1200.  
  1201.    CRLF = Chr$(13) & Chr$(10)
  1202.    a$ = "Device Name: " & agGetSTringFromLPSTR$(dm.dmDeviceName) & CRLF
  1203.    a$ = a$ & "Devmode Version: " & Hex$(dm.dmSpecVersion) & CRLF
  1204.    a$ = a$ & "Horizontal Resolution: " & Str$(dm.dmPrintQuality) & CRLF
  1205.    a$ = a$ & "Vertical Resolution: " & Str$(dm.dmYResolution)
  1206.    MsgBox a
  1207. End Sub
  1208.  
  1209. Function SplitLines% (ByVal prhdc%, ByVal TString$, ByVal MaxLength!)
  1210.    '---------------------------------------------------------------------
  1211.    'This routine takes the string TString$ and splits it up into lines
  1212.    'which are <= MaxLength long for the printer whose device context
  1213.    'is prhdc
  1214.    '
  1215.    'This is useful when one wishes to print the contents of a text box
  1216.    'or some other long string which is not naturally broken into segments
  1217.    '
  1218.    'Remember that the length is dependent on the printer, the current
  1219.    'font, etc.
  1220.    '
  1221.    'The individual lines are stored in the array "LinesArray" which is
  1222.    'defined in the declarations section.  The maximum number of lines is
  1223.    'set by the constant MaxLinesArray.  This value may be set to
  1224.    'whatever value is needed.  Any remainder of TString$ which does not
  1225.    'fit into LinesArray is returned in RemainStr$ so that you may make
  1226.    'iterative calls if you wish.
  1227.    '
  1228.    'Carriage returns which are embedded in TString$ cause the line to
  1229.    'be split at that point.
  1230.    '---------------------------------------------------------------------
  1231.  
  1232.    Dim TStr1$, TStr2, ArrayCount, TPos%, TLen!, OldTPos%, I%
  1233.    Dim CRPos%, LoopCounter%
  1234.  
  1235.    TStr1 = TString
  1236.    TStr2 = TString
  1237.    TPos = 1
  1238.    CRPos = 1
  1239.    ArrayCount = 1
  1240.    LoopCounter = 0  'testing purposes only
  1241.  
  1242.    For I = 1 To MaxLinesArray
  1243.       LinesArray(I) = ""
  1244.    Next I
  1245.    RemainStr = ""
  1246.    Do While 1
  1247.       LoopCounter = LoopCounter + 1
  1248.       If LoopCounter >= 25 Then
  1249.      LoopCounter = LoopCounter
  1250.       End If
  1251.       If ArrayCount > MaxLinesArray Then Exit Do
  1252.       TPos = InStr(TPos, TStr1, " ")
  1253.       CRPos = InStr(1, TStr1, Chr(13))
  1254.       If CRPos > 0 And CRPos < TPos Then
  1255.      LinesArray(ArrayCount) = Left(TStr1, CRPos - 1)
  1256.      TPos = 1
  1257.      TStr1 = Right$(TStr1, Len(TStr1) - (Len(LinesArray(ArrayCount)) + 2))
  1258.      ArrayCount = ArrayCount + 1
  1259.      If ArrayCount > MaxLinesArray Then
  1260.         RemainStr = TStr1
  1261.         Exit Do
  1262.      End If
  1263.       Else
  1264.      If TPos > 0 Then
  1265.         TStr2 = Left(TStr1, TPos - 1)
  1266.         TLen = GetTextWidth(prhdc, TStr2) / PrtYRes
  1267.         If TLen < MaxLength Then
  1268.            LinesArray(ArrayCount) = TStr2
  1269.            OldTPos = TPos
  1270.            TPos = TPos + 1
  1271.         Else
  1272.            TPos = 1
  1273.            TStr1 = Right$(TStr1, Len(TStr1) - (Len(LinesArray(ArrayCount)) + 1))
  1274.            ArrayCount = ArrayCount + 1
  1275.            If ArrayCount > MaxLinesArray Then
  1276.           RemainStr = TStr1
  1277.           Exit Do
  1278.            End If
  1279.         End If
  1280.      Else
  1281.         LinesArray(ArrayCount) = TStr2
  1282.         TLen = GetTextWidth(prhdc, TStr1) / PrtYRes
  1283.         If TLen < MaxLength Then
  1284.            LinesArray(ArrayCount) = TStr1
  1285.            TStr1 = ""
  1286.         Else
  1287.            TStr1 = Right(TStr1, Len(TStr1) - OldTPos)
  1288.         End If
  1289.         ArrayCount = ArrayCount + 1
  1290.         If ArrayCount > MaxLinesArray Then
  1291.            RemainStr = TStr1
  1292.            Exit Do
  1293.         End If
  1294.         LinesArray(ArrayCount) = TStr1
  1295.         TPos = 1
  1296.         Exit Do
  1297.      End If
  1298.       End If
  1299.    Loop
  1300.    SplitLines = ArrayCount
  1301. End Function
  1302.  
  1303. Function StartAPage% (ByVal prhdc%)
  1304.    'must be called at the beginning of each page
  1305.  
  1306.     StartAPage = StartPage(prhdc%)
  1307. End Function
  1308.  
  1309. Function StartDocument% (ByVal prhdc%)
  1310.     'called at the beginning of a document
  1311.  
  1312.     StartDocument = StartDoc(prhdc%, dinfo)
  1313. End Function
  1314.  
  1315. Sub UnloadAbortForm ()
  1316.     Unload AbortForm
  1317. End Sub
  1318.  
  1319.